home *** CD-ROM | disk | FTP | other *** search
/ PC World 2007 March / PCWorld_2007-03_cd.bin / domacnost a kancelar / scribus / scribus-1.3.3.7-win32-install.exe / tcl / tix8.1 / Utils.tcl < prev    next >
Text File  |  2001-11-03  |  12KB  |  504 lines
  1. # -*- mode: TCL; fill-column: 75; tab-width: 8; coding: iso-latin-1-unix -*-
  2. #
  3. #    $Id: Utils.tcl,v 1.2.2.1 2001/11/03 07:25:12 idiscovery Exp $
  4. #
  5. # Util.tcl --
  6. #
  7. #    The Tix utility commands. Some of these commands are
  8. #    replacement of or extensions to the existing TK
  9. #    commands. Occasionaly, you have to use the commands inside
  10. #    this file instead of thestandard TK commands to make your
  11. #    applicatiion work better with Tix. Please read the
  12. #    documentations (programmer's guide, man pages) for information
  13. #    about these utility commands.
  14. #
  15. # Copyright (c) 1993-1999 Ioi Kim Lam.
  16. # Copyright (c) 2000-2001 Tix Project Group.
  17. #
  18. # See the file "license.terms" for information on usage and redistribution
  19. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  20. #
  21.  
  22.  
  23. #
  24. # kludge: should be able to handle all kinds of flags
  25. #         now only handles "-flag value" pairs.
  26. #
  27. proc tixHandleArgv {p_argv p_options validFlags} {
  28.     upvar $p_options opt
  29.     upvar $p_argv    argv
  30.  
  31.     set old_argv $argv
  32.     set argv ""
  33.  
  34.     tixForEach {flag value} $old_argv {
  35.     if {[lsearch $validFlags $flag] != "-1"} {
  36.         # The caller will handle this option exclusively
  37.         # It won't be added back to the original arglist
  38.         #
  39.         eval $opt($flag,action) $value
  40.     } else {
  41.         # The caller does not handle this option
  42.         #
  43.         lappend argv $flag
  44.         lappend argv $value
  45.     }
  46.     }
  47. }
  48.  
  49. #-----------------------------------------------------------------------
  50. # tixDisableAll -
  51. #
  52. #     Disable all members in a sub widget tree
  53. #
  54. proc tixDisableAll {w} {
  55.     foreach x [tixDescendants $w] {
  56.     catch {$x config -state disabled}
  57.     }
  58. }
  59.  
  60. #----------------------------------------------------------------------
  61. # tixEnableAll -
  62. #
  63. #     enable all members in a sub widget tree
  64. #
  65. proc tixEnableAll {w} {
  66.     foreach x [tixDescendants $w] {
  67.     catch {$x config -state normal}
  68.     }
  69. }
  70.  
  71. #----------------------------------------------------------------------
  72. # tixDescendants -
  73. #
  74. #    Return a list of all the member of a widget subtree, including
  75. # the tree's root widget.
  76. #
  77. proc tixDescendants {parent} {
  78.     set des ""
  79.     lappend des $parent
  80.  
  81.     foreach w [winfo children $parent] {
  82.     foreach x [tixDescendants $w] {
  83.         lappend des $x
  84.     }
  85.     }
  86.     return $des
  87. }
  88.  
  89.  
  90. #----------------------------------------------------------------------
  91. # tixForEach -
  92. #
  93. #     Extension of foreach, can handle more than one names
  94. #
  95. #
  96. proc tixForEach {names list body} {
  97.     set len [llength $list]
  98.     set i 0
  99.  
  100.     while {$i < $len} {
  101.     foreach name $names {
  102.         uplevel 1 [list set $name [lindex $list $i]]
  103.         incr i
  104.     }
  105.  
  106.     if {$i > $len} {
  107.         error "incorrect number of items in the list \{$list\}"
  108.     }
  109.  
  110.     uplevel 1 $body
  111.     }
  112. }
  113.  
  114. #----------------------------------------------------------------------
  115. # tixTopLevel -
  116. #
  117. #    Create a toplevel widget and unmap it immediately. This will ensure
  118. # that this toplevel widgets will not be popped up prematurely when you
  119. # create Tix widgets inside it.
  120. #
  121. #    "tixTopLevel" also provide options for you to specify the appearance
  122. # and behavior of this toplevel.
  123. #
  124. #
  125. #
  126. proc tixTopLevel {w args} {
  127.     set opt (-geometry) ""
  128.     set opt (-minsize)  ""
  129.     set opt (-maxsize)  ""
  130.     set opt (-width)    ""
  131.     set opt (-height)   ""
  132.  
  133.     eval toplevel $w $args
  134.     wm withdraw $w
  135. }
  136.  
  137. # This is a big kludge
  138. #
  139. #    Substitutes all [...] and $.. in the string in $args
  140. #
  141. proc tixInt_Expand {args} {
  142.     return $args
  143. }
  144.  
  145. # Print out all the config options of a widget
  146. #
  147. proc tixPConfig {w} {
  148.     foreach opt [lsort [$w config]] {
  149.     puts $opt
  150.     }
  151. }
  152.  
  153. proc tixAppendBindTag {w tag} {
  154.     bindtags $w [concat [bindtags $w] $tag]
  155. }
  156.  
  157. proc tixAddBindTag {w tag} {
  158.     bindtags $w [concat $tag [bindtags $w] ]
  159. }
  160.  
  161. proc tixSubwidgetRef {sub} {
  162.     global tixSRef
  163.  
  164.     return $tixSRef($sub)
  165. }
  166.  
  167. proc tixSubwidgetRetCreate {sub ref} {
  168.     global tixSRef
  169.  
  170.     set tixSRef($sub) $ref
  171. }
  172.  
  173. proc tixSubwidgetRetDelete {sub} {
  174.     global tixSRef
  175.  
  176.     catch {unset tixSRef($sub)}
  177. }
  178.  
  179. proc tixListboxGetCurrent {listbox} {
  180.     return [tixEvent flag V]
  181. }
  182.  
  183.  
  184. # tixSetMegaWidget --
  185. #
  186. #    Associate a subwidget with its mega widget "owner". This is mainly
  187. #    used when we add a new bindtag to a subwidget and we need to find out
  188. #    the name of the mega widget inside the binding.
  189. #
  190. proc tixSetMegaWidget {w mega {type any}} {
  191.     global tixMega
  192.  
  193.     set tixMega($type,$w) $mega
  194. }
  195.  
  196. proc tixGetMegaWidget {w {type any}} {
  197.     global tixMega
  198.  
  199.     return $tixMega($type,$w)
  200. }
  201.  
  202. proc tixUnsetMegaWidget {w} {
  203.     global tixMega
  204.  
  205.     if {[info exists tixMega($w)]} {
  206.     unset tixMega($w)
  207.     }
  208. }
  209.  
  210. # tixBusy : display busy cursors on a window
  211. #
  212. #
  213. # Should flush the event queue (but not do any idle tasks) before blocking
  214. # the target window (I am not sure if it is aready doing so )
  215. #
  216. # ToDo: should take some additional windows to raise
  217. #
  218. proc tixBusy {w flag {focuswin ""}} {
  219.  
  220.     if {[info command tixInputOnly] == ""} {
  221.     return
  222.     }
  223.  
  224.     global tixBusy
  225.     set toplevel [winfo toplevel $w]
  226.  
  227.     if {![info exists tixBusy(cursor)]} {
  228.     set tixBusy(cursor) watch
  229. #    set tixBusy(cursor) "[tix getbitmap hourglass] \
  230. #        [string range [tix getbitmap hourglass.mask] 1 end]\
  231. #         black white"
  232.     }
  233.  
  234.     if {$toplevel == "."} {
  235.     set inputonly0 .__tix__busy0
  236.     set inputonly1 .__tix__busy1
  237.     set inputonly2 .__tix__busy2
  238.     set inputonly3 .__tix__busy3
  239.     } else {
  240.     set inputonly0 $toplevel.__tix__busy0
  241.     set inputonly1 $toplevel.__tix__busy1
  242.     set inputonly2 $toplevel.__tix__busy2
  243.     set inputonly3 $toplevel.__tix__busy3
  244.     }
  245.  
  246.     if {![winfo exists $inputonly0]} {
  247.     for {set i 0} {$i < 4} {incr i} {
  248.         tixInputOnly [set inputonly$i] -cursor $tixBusy(cursor)
  249.     }
  250.     }
  251.  
  252.     case $flag {
  253.     on {
  254.         if {$focuswin != "" && [winfo id $focuswin] != 0} {
  255.         if {[info exists tixBusy($focuswin,oldcursor)]} {
  256.             return
  257.         }
  258.         set tixBusy($focuswin,oldcursor) [$focuswin cget -cursor]
  259.         $focuswin config -cursor $tixBusy(cursor)
  260.  
  261.         set x1 [expr [winfo rootx $focuswin]-[winfo rootx $toplevel]]
  262.         set y1 [expr [winfo rooty $focuswin]-[winfo rooty $toplevel]]
  263.  
  264.         set W  [winfo width $focuswin]
  265.         set H  [winfo height $focuswin]
  266.         set x2 [expr $x1 + $W]
  267.         set y2 [expr $y1 + $H]
  268.  
  269.  
  270.         if {$y1 > 0} {
  271.             tixMoveResizeWindow $inputonly0 0   0   10000 $y1
  272.         }
  273.         if {$x1 > 0} {
  274.             tixMoveResizeWindow $inputonly1 0   0   $x1   10000
  275.         }
  276.         tixMoveResizeWindow $inputonly2 0   $y2 10000 10000
  277.         tixMoveResizeWindow $inputonly3 $x2 0   10000 10000
  278.  
  279.         for {set i 0} {$i < 4} {incr i} {
  280.             tixMapWindow [set inputonly$i] 
  281.             tixRaiseWindow [set inputonly$i]
  282.         }
  283.         tixFlushX $w
  284.         } else {
  285.         tixMoveResizeWindow $inputonly0 0 0 10000 10000
  286.         tixMapWindow $inputonly0
  287.         tixRaiseWindow $inputonly0
  288.         }
  289.     }
  290.     off {
  291.         tixUnmapWindow $inputonly0
  292.         tixUnmapWindow $inputonly1
  293.         tixUnmapWindow $inputonly2
  294.         tixUnmapWindow $inputonly3
  295.  
  296.         if {$focuswin != "" && [winfo id $focuswin] != 0} {
  297.         if {[info exists tixBusy($focuswin,oldcursor)]} {
  298.             $focuswin config -cursor $tixBusy($focuswin,oldcursor)
  299.             if {[info exists tixBusy($focuswin,oldcursor)]} {
  300.             unset tixBusy($focuswin,oldcursor)
  301.             }
  302.         }
  303.         }
  304.     }
  305.     }
  306.    
  307. }
  308.  
  309. proc tixOptionName {w} {
  310.     return [string range $w 1 [expr [string length $w]-1]]
  311. }
  312.  
  313. proc tixSetSilent {chooser value} {
  314.     $chooser config -disablecallback true
  315.     $chooser config -value $value
  316.     $chooser config -disablecallback false
  317. }
  318.  
  319. proc tixSetChooser {chooser value} {
  320.  
  321.     puts "obsolete command tixSetChooser, call tixSetSilent instead"
  322.  
  323.     $chooser config -disablecallback true
  324.     $chooser config -value $value
  325.     $chooser config -disablecallback false
  326. }
  327.  
  328. # This command is useful if you want to ingore the arguments
  329. # passed by the -command or -browsecmd options of the Tix widgets. E.g
  330. #
  331. # tixFileSelectDialog .c -command "puts foo; tixBreak"
  332. #
  333. #
  334. proc tixBreak {args} {}
  335.  
  336. #----------------------------------------------------------------------
  337. # tixDestroy -- deletes a Tix class object (not widget classes)
  338. #----------------------------------------------------------------------
  339. proc tixDestroy {w} {
  340.     upvar #0 $w data
  341.     
  342.     set destructor ""
  343.     if {[info exists data(className)]} {
  344.     catch {
  345.         set destructor [tixGetMethod $w $data(className) Destructor]
  346.     }
  347.     }
  348.     if {$destructor != ""} {
  349.     $destructor $w
  350.     }
  351.     catch {
  352.     rename $w ""
  353.     }
  354.     catch {
  355.     unset data
  356.     }
  357.     return ""
  358. }
  359.  
  360. proc tixPushGrab {args} {
  361.     global tix_priv
  362.  
  363.     if {![info exists tix_priv(grab-list)]} {
  364.     set tix_priv(grab-list)    ""
  365.     set tix_priv(grab-mode)    ""
  366.     set tix_priv(grab-nopush) ""
  367.     }
  368.  
  369.     case [llength $args] {
  370.     1 {
  371.         set opt ""
  372.         set w [lindex $args 0]
  373.     }
  374.     2 {
  375.         set opt [lindex $args 0]
  376.         set w [lindex $args 1]
  377.     }
  378.     default {
  379.         error "wrong #of arguments: tixPushGrab ?-global? window"
  380.     }
  381.     }
  382.  
  383.     # Not everyone will call tixPushGrab. If someone else has a grab already
  384.     # save that one as well, so that we can restore that later
  385.     #
  386.     set last [lindex $tix_priv(grab-list) end]
  387.     set current [grab current $w]
  388.  
  389.     if {$current != "" && $current != $last} {
  390.     # Someone called "grab" directly
  391.     #
  392.     lappend tix_priv(grab-list)    $current
  393.     lappend tix_priv(grab-mode)    [grab status $current]
  394.     lappend tix_priv(grab-nopush) 1
  395.     }
  396.  
  397.     # Now push myself into the stack
  398.     #
  399.     lappend tix_priv(grab-list)    $w
  400.     lappend tix_priv(grab-mode)    $opt
  401.     lappend tix_priv(grab-nopush) 0
  402.  
  403.     if {$opt == "-global"} {
  404.     grab -global $w
  405.     } else {
  406.     grab $w
  407.     }
  408. }
  409.  
  410. proc tixPopGrab {} {
  411.     global tix_priv
  412.  
  413.     if {![info exists tix_priv(grab-list)]} {
  414.     set tix_priv(grab-list)   ""
  415.     set tix_priv(grab-mode)   ""
  416.     set tix_priv(grab-nopush) ""
  417.     }
  418.  
  419.     set len [llength $tix_priv(grab-list)]
  420.     if {$len <= 0} {
  421.     error "no window is grabbed by tixGrab"
  422.     }
  423.  
  424.     set w [lindex $tix_priv(grab-list) end]
  425.     grab release $w
  426.  
  427.     if {$len > 1} {
  428.     set tix_priv(grab-list)   \
  429.         [lrange $tix_priv(grab-list) 0 [expr $len-2]]
  430.     set tix_priv(grab-mode)   \
  431.         [lrange $tix_priv(grab-mode) 0 [expr $len-2]]
  432.     set tix_priv(grab-nopush) \
  433.         [lrange $tix_priv(grab-nopush) 0 [expr $len-2]]
  434.  
  435.     set w  [lindex $tix_priv(grab-list) end]
  436.     set m  [lindex $tix_priv(grab-list) end]
  437.     set np [lindex $tix_priv(grab-nopush) end]
  438.  
  439.     if {$np == 1} {
  440.         # We have a grab set by "grab"
  441.         #
  442.         set len [llength $tix_priv(grab-list)]
  443.  
  444.         if {$len > 1} {
  445.         set tix_priv(grab-list)   \
  446.             [lrange $tix_priv(grab-list) 0 [expr $len-2]]
  447.         set tix_priv(grab-mode)   \
  448.             [lrange $tix_priv(grab-mode) 0 [expr $len-2]]
  449.         set tix_priv(grab-nopush) \
  450.             [lrange $tix_priv(grab-nopush) 0 [expr $len-2]]
  451.         } else {
  452.         set tix_priv(grab-list)   ""
  453.         set tix_priv(grab-mode)   ""
  454.         set tix_priv(grab-nopush) ""
  455.         }
  456.     }
  457.  
  458.     if {$m == "-global"} {
  459.         grab -global $w
  460.     } else {
  461.         grab $w
  462.     }
  463.     } else {
  464.       set tix_priv(grab-list)   ""
  465.     set tix_priv(grab-mode)   ""
  466.     set tix_priv(grab-nopush) ""
  467.     }
  468. }
  469.  
  470. proc tixWithinWindow {wid rootX rootY} {
  471.     set rx1 [winfo rootx $wid]
  472.     set ry1 [winfo rooty $wid]
  473.     set rw  [winfo width  $wid]
  474.     set rh  [winfo height $wid]
  475.     set rx2 [expr $rx1+$rw]
  476.     set ry2 [expr $ry1+$rh]
  477.  
  478.     if {$rootX >= $rx1 && $rootX < $rx2 && $rootY >= $ry1 && $rootY < $ry2} {
  479.     return 1
  480.     } else {
  481.     return 0
  482.     }
  483. }
  484.  
  485. proc tixWinWidth {w} {
  486.     set W [winfo width $w]
  487.     set bd [expr [$w cget -bd] + [$w cget -highlightthickness]]
  488.  
  489.     return [expr $W - 2*$bd]
  490. }
  491.  
  492. proc tixWinHeight {w} {
  493.     set H [winfo height $w]
  494.     set bd [expr [$w cget -bd] + [$w cget -highlightthickness]]
  495.  
  496.     return [expr $H - 2*$bd]
  497. }
  498.  
  499. # junk?
  500. #
  501. proc tixWinCmd {w} {
  502.     return [winfo command $w]
  503. }
  504.